home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Moscow ML 1.42 / src / !runtime / interncp.c < prev    next >
Encoding:
C/C++ Source or Header  |  1997-08-18  |  4.8 KB  |  179 lines  |  [TEXT/R*ch]
  1. /* Structured input, compact format */
  2.  
  3. #include "debugger.h"
  4. #include "fail.h"
  5. #include "gc.h"
  6. #include "intext.h"
  7. #include "io.h"
  8. #include "memory.h"
  9. #include "mlvalues.h"
  10. #include "reverse.h"
  11.  
  12. static header_t * intern_ptr;
  13. static asize_t obj_counter;
  14. static value * intern_obj_table;
  15. static unsigned int intern_color;
  16. static header_t intern_header;
  17. static value intern_block;
  18.  
  19. static long input_bytes(chan, nbytes, sign_extend)
  20.      struct channel * chan;
  21.      int nbytes, sign_extend;
  22. {
  23.   long res;
  24.   int i;
  25.   res = getch(chan);
  26.   if (sign_extend)
  27.     res = (res << ((sizeof(long) - 1) * 8)) >> ((sizeof(long) - 1) * 8);
  28.   for (i = 1; i < nbytes; i++)
  29.     res = (res << 8) + getch(chan);
  30.   return res;
  31. }
  32.  
  33. static void read_compact(chan, dest)
  34.      struct channel * chan;
  35.      value * dest;
  36. {
  37.   unsigned int code;
  38.   tag_t tag;
  39.   mlsize_t size, len, ofs_ind;
  40.   value v;
  41.   asize_t ofs;
  42.   header_t header;
  43.  
  44.  tailcall:
  45.   code = getch(chan);
  46.   if (code >= PREFIX_SMALL_INT) {
  47.     if (code >= PREFIX_SMALL_BLOCK) {
  48.       /* Small block */
  49.       tag = code & 0xF;
  50.       size = (code >> 4) & 0x7;
  51.     read_block:
  52.       if (size == 0) {
  53.         v = Atom(tag);
  54.       } else {
  55.         v = Val_hp(intern_ptr);
  56.         *dest = v;
  57.         intern_obj_table[obj_counter++] = v;
  58.         dest = (value *) (intern_ptr + 1);
  59.         *intern_ptr = Make_header(size, tag, intern_color);
  60.         intern_ptr += 1 + size;
  61.         for(/*nothing*/; size > 1; size--, dest++)
  62.           read_compact(chan, dest);
  63.         goto tailcall;
  64.       }
  65.     } else {
  66.       /* Small integer */
  67.       v = Val_int(code & 0x3F);
  68.     }
  69.   } else {
  70.     if (code >= PREFIX_SMALL_STRING) {
  71.       /* Small string */
  72.       len = (code & 0x1F);
  73.     read_string:
  74.       size = (len + sizeof(value)) / sizeof(value);
  75.       v = Val_hp(intern_ptr);
  76.       intern_obj_table[obj_counter++] = v;
  77.       *intern_ptr = Make_header(size, String_tag, intern_color);
  78.       intern_ptr += 1 + size;
  79.       Field(v, size - 1) = 0;
  80.       ofs_ind = Bsize_wsize(size) - 1;
  81.       Byte(v, ofs_ind) = ofs_ind - len;
  82.       really_getblock(chan, String_val(v), len);
  83.     } else {
  84.       switch(code) {
  85.       case CODE_INT8:
  86.         v = Val_long(input_bytes(chan, 1, 1));
  87.         break;
  88.       case CODE_INT16:
  89.         v = Val_long(input_bytes(chan, 2, 1));
  90.         break;
  91.       case CODE_INT32:
  92.         v = Val_long(input_bytes(chan, 4, 1));
  93.         break;
  94.       case CODE_INT64:
  95. #ifdef SIXTYFOUR
  96.         v = Val_long(input_bytes(chan, 8, 1));
  97.         break;
  98. #else
  99.         stat_free((char *) intern_obj_table);
  100.         Hd_val(intern_block) = intern_header; /* Don't confuse the GC */
  101.         failwith("input_value: integer too large");
  102.         break;
  103. #endif
  104.       case CODE_SHARED8:
  105.         ofs = input_bytes(chan, 1, 0);
  106.       read_shared:
  107.         Assert(ofs > 0 && ofs <= obj_counter); 
  108.         v = intern_obj_table[obj_counter - ofs];
  109.         break;
  110.       case CODE_SHARED16:
  111.         ofs = input_bytes(chan, 2, 0);
  112.         goto read_shared;
  113.       case CODE_SHARED32:
  114.         ofs = input_bytes(chan, 4, 0);
  115.         goto read_shared;
  116.       case CODE_BLOCK32:
  117.         header = (header_t) input_bytes(chan, 4, 0);
  118.         tag = Tag_hd(header);
  119.         size = Wosize_hd(header);
  120.         goto read_block;
  121.       case CODE_STRING8:
  122.         len = input_bytes(chan, 1, 0);
  123.         goto read_string;
  124.       case CODE_STRING32:
  125.         len = input_bytes(chan, 4, 0);
  126.         goto read_string;
  127.       case CODE_DOUBLE:
  128.         if (sizeof(double) != 8) {
  129.           stat_free((char *) intern_obj_table);
  130.           Hd_val(intern_block) = intern_header; /* Don't confuse the GC */
  131.           invalid_argument("input_value: non-standard floats");
  132.         }
  133.         v = Val_hp(intern_ptr);
  134.         intern_obj_table[obj_counter++] = v;
  135.         *intern_ptr = Make_header(Double_wosize, Double_tag, intern_color);
  136.         intern_ptr += 1 + Double_wosize;
  137.         really_getblock(chan, (char *) v, 8);
  138. #ifndef MOSML_BIG_ENDIAN
  139.         Reverse_double(v);
  140. #endif
  141.         break;
  142.       }
  143.     }
  144.   }
  145.   *dest = v;
  146. }
  147.  
  148. value intern_compact_val(chan)
  149.      struct channel * chan;
  150. {
  151.   mlsize_t num_objects, size_32, size_64, whsize;
  152.   value res;
  153.  
  154.   num_objects = getword(chan);
  155.   size_32 = getword(chan);
  156.   size_64 = getword(chan);
  157. #ifdef SIXTYFOUR
  158.   whsize = size_64;
  159. #else
  160.   whsize = size_32;
  161. #endif
  162.   if (whsize == 0) {
  163.     read_compact(chan, &res);
  164.   } else {
  165.     if (Wosize_whsize(whsize) > Max_wosize)
  166.       failwith("intern: structure too big");
  167.     intern_block = alloc_shr(Wosize_whsize(whsize), String_tag);
  168.     intern_header = Hd_val(intern_block);
  169.     intern_color = Color_hd(intern_header);
  170.     Assert (intern_color == White || intern_color == Black);
  171.     intern_ptr = (header_t *) Hp_val(intern_block);
  172.     obj_counter = 0;
  173.     intern_obj_table = (value *) stat_alloc(num_objects * sizeof(value));
  174.     read_compact(chan, &res);
  175.     stat_free((char *) intern_obj_table);
  176.   }
  177.   return res;
  178. }
  179.